Delphi Programmer's Power Pack/Delphi Volume 1.iso/s_to_z/statone/dynary.pas

Pascal/Delphi Source File | 1996-09-15 | 6.4 KB | 280 lines

unit dynary;

interface

uses
      SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
      Forms, Dialogs;

const
    MAX_SIZE = 8000;
    VERSION = 'Ver 0.3';

type
    CompFunc = Function(V1,V2:Pointer):Boolean;
    TElement = Double;
  TIndex = WORD;
    PElement = ^TElement;
  TTheArray = Array[1..MAX_SIZE] of TElement;
  PArray = ^TTheArray;

  TDoubleArray     = class(TComponent)

  private
    { Private declarations }
    FAbout: string;
        FSize: TIndex;
    FArray: TTheArray;
    FArrayPtr: PArray;
    FArrayAssigned: Boolean;
    PROCEDURE SetArrayValue(idx: TIndex; CONST NewElement: TElement);
    FUNCTION GetArrayValue(idx: TIndex): TElement;
    PROCEDURE CreateArray(CONST Size: TIndex);
    PROCEDURE DestroyArray;
    PROCEDURE InitializeArrayElements(CONST LoInit, HiInit:TIndex);
    procedure SetAbout(value: string);

  protected

  public
    property Value[idx: TIndex]: TElement read GetArrayValue write SetArrayValue; default;
    procedure Sort;
    {property AddrOfElement[idx: TIndex]: PElement read GetElementAddress;}

  published
    property Size: TIndex read  FSize write FSize;
    FUNCTION CheckRange(CONST N: TIndex):BOOLEAN;
    FUNCTION SetSize(Size: TIndex): BOOLEAN;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property About: string read FAbout write SetAbout;
end;

Procedure SortProcedure(Var     Struct;                    { array of any Type }
                                        Num,            { Number of elements }
                                        ElementSize:Integer;   { Size of each element ( byte ) }
                                        Comp:CompFunc); { Type of compare function to use}

Function IntComp(I1,I2:Pointer):Boolean;   far;
Function SingleComp(r1,r2:Pointer):Boolean;  far;
Function RealComp(r1,r2:Pointer):Boolean;  far;
Function DoubleComp(r1,r2:Pointer):Boolean;  far;
Function ByteComp(b1,b2:Pointer):Boolean;  far;
Function CharComp(c1,c2:Pointer):Boolean;  far;
Function StringComp(s1,s2:Pointer):Boolean;far;

procedure register;

{===========================================}
implementation
CONSTRUCTOR TDoubleArray.Create(AOwner: TComponent);
BEGIN
  inherited Create(AOwner);
  FAbout := VERSION;
  IF FSize > 0 THEN
    CreateArray(Size)
  ELSE
    FArrayAssigned := FALSE;
    FSize := 0;
END;

DESTRUCTOR TDoubleArray.Destroy;
BEGIN
  DestroyArray;
  inherited Destroy;
END;

PROCEDURE TDoubleArray.InitializeArrayElements (CONST LoInit, HiInit: TIndex);
VAR
    idx: TIndex;
BEGIN
  FOR idx := LoInit TO HiInit DO
    FArrayPtr^[idx] := 0.0;
END;

PROCEDURE TDoubleArray.CreateArray(CONST Size: TIndex);
BEGIN
  GetMem(FArrayPtr, Size * SizeOf(TElement));
  FSize := Size;
  InitializeArrayElements(1, FSize);
  FArrayAssigned := TRUE
END;

PROCEDURE TDoubleArray.DestroyArray;
BEGIN
  FreeMem(FArrayPtr, FSize * SizeOf(TElement));
  FArrayAssigned := FALSE;
END;

FUNCTION TDoubleArray.CheckRange(CONST N: TIndex): BOOLEAN;
BEGIN
  IF (N > FSize) OR (N < 1) THEN
    Result := FALSE
  ELSE
    Result := TRUE;
END;

PROCEDURE TDoubleArray.SetArrayValue(idx: TIndex; CONST NewElement: TElement);
BEGIN
  FArray[idx] := NewElement;
END;

FUNCTION TDoubleArray.GetArrayValue(idx: TIndex): TElement;
BEGIN
  Result := FArray[idx];
END;

FUNCTION TDoubleArray.SetSize(Size: TIndex): BOOLEAN;
BEGIN
    {CHECK THE RANGE}
    IF (Size > MAX_SIZE) OR (Size < 1) THEN
  BEGIN
      Result := FALSE;
    Exit;
  END;

  {SET THE SIZE}
  IF FArrayAssigned = FALSE THEN
      CreateArray(Size)
  ELSE
  begin
      {REALLOCATE ARRAY ROUTINE HERE}
    FreeMem(FArrayPtr, FSize * SizeOf(TElement));
      FArrayAssigned := FALSE;
      CreateArray(Size)
  end;
END;

procedure TDoubleArray.Sort;
begin
    if FSize > 1 then
    SortProcedure(FArray, FSize, 8, DoubleComp);
end;


Procedure SortProcedure{...};

  var
    Temp:Pointer;
    StructBase:Array[0..0] of Byte Absolute Struct;

  Function VLoc(n:integer):Pointer;
    { Note that no range check is performed! }
    Begin
      {$R-}
      VLoc:=Addr(structBase[n*ElementSize]);
      {$R+}
    End;

  Procedure Swap(n1,n2:Integer);
    { swap two elements }
    Begin
      Move(VLoc(n1)^,Temp^,ElementSize);
      Move(VLoc(n2)^,VLoc(n1)^,ElementSize);
      Move(Temp^,VLoc(n2)^,ElementSize);
    End;

  { Quick sort routine }
  Procedure Qsort(l,r:Integer);
    Var
      i,j:Integer;
      Pivot:Pointer;
    Begin
      i:=l;
      j:=r;
      GetMem(Pivot,ElementSize);  { Hopefully, the midpoint}
      Move(Vloc((L+r) div 2)^,Pivot^,ElementSize);
      Repeat
        while Comp(Pivot,Vloc(i)) do inc(i);
        while Comp(Vloc(J),pivot) do Dec(j);
        if i<=j then
          Begin
            Swap(i,j);
            Inc(i);
            Dec(j);
          End;
      until i>j;
      if j>l then Qsort(l,j); { recoursive call }
      if i<r then Qsort(i,r);
      FreeMem(Pivot,ElementSize);
    End;
  begin
      GetMem(Temp,ElementSize);   { Temp is used for swap }
    if num>1 then
      Qsort(0,Num-1);
    FreeMem(Temp,ElementSize);
  end;

Function IntComp(I1,I2:Pointer):Boolean;
  Type
    IntPtr=^Integer;
  Var
    v1:IntPtr absolute I1;
    v2:IntPtr absolute I2;
  Begin
    IntComp:=V1^>V2^;
  End;
Function SingleComp(r1,r2:Pointer):Boolean;
  Type
    SinglePtr=^Single;
  Var
    v1:SinglePtr absolute r1;
    v2:SinglePtr absolute r2;
  Begin
    SingleComp:=V1^>V2^;
  End;
Function RealComp(r1,r2:Pointer):Boolean;
  Type
    RealPtr=^Real;
  Var
    v1:RealPtr absolute r1;
    v2:RealPtr absolute r2;
  Begin
    RealComp:=V1^>V2^;
  End;
Function DoubleComp(r1,r2:Pointer):Boolean;
  Type
    DoublePtr=^Double;
  Var
    v1:DoublePtr absolute r1;
    v2:DoublePtr absolute r2;
  Begin
    DoubleComp:=V1^>V2^;
  End;
Function ByteComp(b1,b2:Pointer):Boolean;
  Type
    BytePtr=^Byte;
  Var
    v1:BytePtr absolute b1;
    v2:BytePtr absolute b2;
  Begin
    ByteComp:=V1^>V2^;
  End;
Function CharComp(c1,c2:Pointer):Boolean;
  Begin
    CharComp:=ByteComp(c1,c2); { Byte and char are the same! }
  End;
Function StringComp(s1,s2:Pointer):Boolean;
  Type
    StringPtr=^String;
  Var
    v1:StringPtr absolute s1;
    v2:StringPtr absolute s2;
  Begin
    StringComp:=V1^>V2^;
  End;

procedure TDoubleArray.SetAbout(value: string);
begin
    FAbout := VERSION;
end;

PROCEDURE Register;
BEGIN
    RegisterComponents('Ted', [TDoubleArray]);
END;

end.